home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel-075.lha / feel0.75 / Src / macros0.em < prev    next >
Lisp/Scheme  |  1992-06-18  |  4KB  |  157 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;                                                                           ;;
  3. ;;   EuLisp Module  -   Copyright (C) Codemist and University of Bath 1990   ;;
  4. ;;                                                                           ;;
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6.  
  7. ;;
  8.  
  9. ;; Change Log:
  10. ;;   Version 1.0 
  11.  
  12. ;;
  13.  
  14. (defmodule macros0
  15.  
  16.   (calls ccc lists list-operators others arith) ()
  17.  
  18.   ;; The compiler syntax is a little different...
  19.   
  20.   (deflocal *defs-compile-time* ())
  21.  
  22.   (defun compile-time-p ()
  23.     *defs-compile-time*)
  24.  
  25.   ((setter setter) compile-time-p
  26.    (lambda (x) (setq *defs-compile-time* x)))
  27.   
  28.   (export compile-time-p)
  29.  
  30.   (defmacro compile-time forms
  31.     (if (compile-time-p)
  32.     `(progn ,@forms)
  33.       nil))
  34.   
  35.   (defmacro interpret-time forms
  36.     (if (compile-time-p)
  37.     nil
  38.       `(progn ,@forms)))
  39.  
  40.   (export compile-time  interpret-time)
  41.  
  42.   ;; Control Extentions - Conditional Extentions
  43.   (defmacro cond b
  44.     (if b (if (cdr (car b)) (list 'if (car (car b)) (cons 'progn (cdr (car b)))
  45.                   (cons 'cond (cdr b)))
  46.         (list 'or (car (car b)) (cons 'cond (cdr b))))
  47.       ()))
  48.  
  49.   ;; Control Extentions - Binding extentions
  50.   ;; LET expands to LAMBDA
  51.   (defmacro let (bind . body)
  52.     (cons (cons 'lambda (cons (\@letvars bind) body)) (\@letforms bind)))
  53.  
  54.   (defun \@letvars (b)
  55.     (if b (cons (car (car b)) (\@letvars (cdr b)))
  56.       ()))
  57.  
  58.   (defun \@letforms (b)
  59.     (if b (cons (car (cdr (car b))) (\@letforms (cdr b)))
  60.       ()))
  61.  
  62.   ;; LET* expands to LET
  63.   (defmacro let* (bind . body)
  64.     (if bind (list 'let (cons (car bind) ())
  65.            (cons 'let* (cons (cdr bind) body)))
  66.       (cons 'progn body)))
  67.  
  68.   ;; LABELS is a complex LET
  69.   (defmacro labels (binds . body)
  70.     (cons 'let (cons (\@labelsvar binds) (\@labelsbody binds body))))
  71.  
  72.   (defun \@labelsvar (b)
  73.     (if b (cons (list (car (car b)) ()) (\@labelsvar (cdr b)))
  74.       ()))
  75.  
  76.   (defun \@labelsbody (b body)
  77.     (if b (cons (list 'setq (car (car b)) (cons 'lambda (cdr (car b))))
  78.             (\@labelsbody (cdr b) body))
  79.       body))
  80.  
  81.   (defmacro and b
  82.     (if b (if (cdr b) (list 'if (car b) (cons 'and (cdr b)) ())
  83.         (car b))
  84.       t))
  85.  
  86.   (defmacro or b
  87.     (if b 
  88.        (if (cdr b) (list 'let (list (list '\@ (car b))) 
  89.               (list 'if '\@ '\@ (cons 'or (cdr b))))
  90.       (car b))
  91.       ()))
  92.  
  93.   (defmacro when (pred . forms) `(if ,pred (progn ,@forms) nil))
  94.   (defmacro unless (pred . forms) `(if ,pred nil (progn ,@forms)))
  95.  
  96.   (export let let* cond and or when unless labels) 
  97.   
  98.   (defmacro unwind-protect (prot . rest)
  99.     `(fn-unwind-protect (lambda () ,prot)
  100.             (lambda () (progn ,@rest))))
  101.  
  102.   (defmacro let/cc (name . forms)
  103.     `(simple-call/cc 
  104.       (lambda (,name) ,@forms)))
  105.  
  106.   (defmacro with-handler (fn . forms)
  107.     `(progn (push-handler ,fn)
  108.         (let ((@ (progn ,@forms)))
  109.           (pop-handler)
  110.           @)))
  111.  
  112.   (export unwind-protect let/cc with-handler)
  113.   ;; Control Extentions - Exit Extentions
  114.   (defmacro block forms (cons 'let/cc forms))
  115.  
  116.   (defmacro return-from (name . forms)
  117.     (list name (cons 'progn forms)))
  118.  
  119.   (export block return-from)
  120.  
  121.   (defmacro catch (tag . body)
  122.     `(let/cc \@
  123.          (dynamic-let ((,tag \@)) ,@body)))
  124.  
  125.   (defmacro throw (tag . forms)
  126.     `((dynamic ,tag) (progn ,@forms)))
  127.  
  128.   (export catch throw)
  129.  
  130.   (defmacro prog1 forms
  131.     `((lambda (@prog1-handle@)
  132.     ,@(cdr forms)
  133.     @prog1-handle@) ,(car forms)))
  134.  
  135.   (export prog1)
  136.  
  137.   ;
  138.   ;; Multiple Values.
  139.   ;;
  140.   ;;  An el-cheapo pseudo implementation.
  141.   ;
  142.  
  143.   ;;(defmacro values forms
  144.   ;;(if (null (cdr forms)) forms
  145.   ;;`(list ,@forms)))
  146.  
  147.   ;;(defun call/mv (f values) (apply f values))
  148.  
  149.   ;;(defmacro let/mv (vars form . body)
  150.   ;;`(call/mv (lambda ,vars ,@body) ,form))
  151.  
  152.   ;;(export values call/mv let/mv)
  153.  
  154.  
  155. )
  156.  
  157.